From 680c12e686b074c8efe0ccf8b2fefb4613d7f268 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 11:35:12 +0700 Subject: [PATCH] A restart frame carries where its clause is written, its :report sentence and whether a handler-case made it up, and the break loop shows the first two and hides the third --- emacs/flan-cnr.el | 41 ++++++++++++++-- emacs/test-flan-cider.el | 31 ++++++++++++ lib/ast.ml | 9 +++- lib/check.ml | 27 +++++++---- lib/dev.ml | 58 +++++++++++++++++++---- lib/emit.ml | 26 ++++++++--- lib/parse.ml | 21 ++++++++- lib/tast.ml | 10 +++- lib/x86.ml | 8 ++++ runtime/flan_rt.c | 65 +++++++++++++++++++++++++- test/agent_hooks.c | 17 ++++--- test/programs/break.flan | 14 +++++- test/programs/dev-break.flan | 2 +- test/test_agent.ml | 37 ++++++++++++--- test/test_dev.ml | 13 ++++++ test/test_flan.ml | 8 ++++ vendor/agent/flan_agent.c | 91 ++++++++++++++++++++++++++++++++++-- 17 files changed, 424 insertions(+), 54 deletions(-) diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 5bc4e1f7..a216d1d6 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -294,6 +294,7 @@ indexing or the division itself, so it sits directly under the headline." (defun flan-cnr--insert-restarts (state) (flan-cnr--section "Restarts (innermost first) — RET or a digit takes one:") (let* ((names (plist-get state :restarts)) + (details (plist-get state :details)) (rows (flan-cnr-annotate-restarts names (plist-get state :unreachable) (plist-get state :abandon) @@ -306,6 +307,12 @@ indexing or the division itself, so it sits directly under the headline." (dolist (r rows) (let* ((i (nth 0 r)) (name (nth 1 r)) (owner (nth 2 r)) (kind (nth 3 r)) + (d (nth i details)) + (report (let ((x (plist-get d :report))) + (and (stringp x) (not (string-empty-p x)) x))) + (params (and (> (or (plist-get d :arity) 0) 0) + (plist-get d :params))) + (at (plist-get d :at)) (start (point))) ;; SBCL's bracket: it is there when the name reaches this frame and ;; gone when it does not. A shadowed entry is still takeable — the @@ -325,6 +332,10 @@ indexing or the division itself, so it sits directly under the headline." (if (or owner (memq kind '(unreachable trapped))) " " "]"))) (insert (make-string (- w (length name)) ?\s)) + ;; What it takes, when it takes anything: taking it asks for one + ;; value of each of these types. + (when params + (insert (propertize params 'face 'font-lock-type-face) " ")) (cond ;; What the reader wants nine times in ten after a C-x C-e went ;; wrong, so it says what it does *and* what it does not: nothing @@ -352,9 +363,19 @@ indexing or the division itself, so it sits directly under the headline." (insert (propertize (format "same name as %d; taken by its number" owner) 'face 'shadow)))) + ;; The clause's own sentence, SBCL's `:report'; after a refusal's + ;; words when there are any, because those say whether it can be + ;; taken at all. The name is the report when the clause wrote + ;; none, as in SBCL, so nothing is added then. + (when (and report (not (eq kind 'abandon))) + (when (or owner (memq kind '(unreachable trapped))) (insert " ")) + (insert report)) + (when at + (insert (propertize (format " (%s)" at) 'face 'shadow))) (insert "\n") (add-text-properties start (point) (list 'flan-cnr-restart name + 'flan-cnr-restart-loc at 'flan-cnr-shadowed owner 'flan-cnr-kind kind 'flan-cnr-index i @@ -604,13 +625,21 @@ puts the likely culprit on top." A frame's location is where its function is written; the stop's is the expression that stopped." (interactive) - (let ((loc (get-text-property (point) 'flan-cnr-loc))) - (unless loc + (let ((loc (get-text-property (point) 'flan-cnr-loc)) + (rloc (get-text-property (point) 'flan-cnr-restart-loc))) + (cond + (loc (flan-visit-loc loc (flan-cnr--loc-subject (point)))) + ;; A restart's clause, which `v' reaches and RET does not: RET takes it. + (rloc (flan-visit-loc rloc (format "restart %s" + (get-text-property (point) + 'flan-cnr-restart)))) + ((get-text-property (point) 'flan-cnr-restart) + (user-error "flan: this restart was established from C and has no source")) + (t (user-error (if (get-text-property (point) 'flan-cnr-frame) "flan: this frame has no location; the program did not report one" - "flan: point is not on a frame or on the stop"))) - (flan-visit-loc loc (flan-cnr--loc-subject (point))))) + "flan: point is not on a frame, a restart or the stop")))))) (defun flan-cnr-toggle-prelude () "Show or hide the prelude's frames in the stack section." @@ -873,6 +902,10 @@ Takes the layout rather than fetching it, so this stays a function from data to data and the fixture-driven tests can drive it without a socket." (list :condition (plist-get reply :condition) :restarts (plist-get reply :restarts) + ;; Beside each name and in the same order: a plist of its `:report' + ;; sentence, where the clause is written (`:at'), and the types it + ;; takes (`:arity', `:params'). + :details (plist-get reply :details) ;; The two facts about that list nothing here could work out. A ;; position is on `:unreachable' when the program will refuse it, and ;; `:abandon' is the position that drops the evaluation this break is diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 84a93172..5f2441d1 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1044,6 +1044,37 @@ would be overwritten. Look again and re-do the edit") (test-flan--check "and the keys are shown" (and (string-match-p "TAB fold" text) (string-match-p "P prelude frames" text)))) +;; What a restart says beside its name: its `:report' sentence, the types it +;; takes, and where its clause is written — and `v' on the row visits that. +(let* ((buf (test-flan--cnr + (list :condition "FileError" + :restarts '("retry" "use-value" "plain") + :details '((:report "Try the file operation again" + :at "/src/files.flan:12:3" :arity 0 :params "()") + (:report "Try again with another path" + :at "/src/files.flan:12:3" :arity 1 + :params "(string)") + (:report "" :at nil :arity 0 :params "()"))))) + (text (with-current-buffer buf (buffer-string)))) + (test-flan--check "a restart's report is beside its name" + (string-match-p "\\[retry\\] +Try the file operation again" text)) + (test-flan--check "and where its clause is written" + (string-match-p "again (/src/files.flan:12:3)" text)) + (test-flan--check "a restart taking values shows their types" + (string-match-p "\\[use-value\\] +(string) Try again with another path" + text)) + (test-flan--check "one with no report and no source shows its name alone" + (string-match-p " 2: \\[plain\\] *\n" text)) + (let ((visited nil)) + (cl-letf (((symbol-function 'flan-visit-loc) + (lambda (loc subject) (setq visited (list loc subject))))) + (with-current-buffer buf + (goto-char (point-min)) + (search-forward " 1: ") + (flan-cnr-visit))) + (test-flan--check "v on a restart visits its clause" + (equal visited '("/src/files.flan:12:3" "restart use-value"))))) + ;; A stopped program with nothing on offer between the error and the top. It ;; is a real state — spec-conditions §2's `error' with no `restart-case' above ;; it — and it must not look like a bug in the buffer. diff --git a/lib/ast.ml b/lib/ast.ml index 41708a09..2fa53c91 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -167,9 +167,14 @@ and hclause = { hty : texpr; hname : string; hbody : expr list; hloc : Loc.t } (* [rparams] are §3's inline annotations, the same name/type pairs a [defn] takes. They are bound in the clause body and filled in by whatever invoked the restart, which is why their count and types are checked at run time - (§3): a restart is found by name on a dynamic stack. *) + (§3): a restart is found by name on a dynamic stack. + + [rreport] is the sentence a break loop shows beside the name, written + [(name [p T] :report "..." body ...)] — Common Lisp's [:report], string + form only. *) and rclause = - { rname : string; rparams : field list; rbody : expr list; rloc : Loc.t } + { rname : string; rparams : field list; rreport : string option; + rbody : expr list; rloc : Loc.t } (* Inline name/type pairs, as in [defn], [let] and [defstruct]. Here because a restart clause's parameters are one, and a clause is part of an expression. *) diff --git a/lib/check.ml b/lib/check.ml index e5106991..84cd0935 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4391,7 +4391,8 @@ and check_restart_case ctx ?want loc body clauses = been checked. Separate from the form above because [handler-case] supplies its own body — a [handler-bind] it built — and has to name itself in the refusals rather than naming the machinery it is made of. *) -and restart_clauses ctx ?want ~what loc (tbody : Tast.expr) clauses = +and restart_clauses ctx ?want ?(hidden = false) ~what loc (tbody : Tast.expr) + clauses = (* With no expectation from outside, the body's own type is the expectation the clauses are checked against — unless it produced no value at all, in which case the first clause that does decides. *) @@ -4445,7 +4446,10 @@ and restart_clauses ctx ?want ~what loc (tbody : Tast.expr) clauses = if !ty = None && b.Tast.ty <> Types.Never then ty := Some b.Tast.ty; let sg = restart_sig (List.map snd params) in { Tast.rname_id = type_id c.Ast.rname; rname = c.Ast.rname; - rparams = params; rsig = sg; rsig_id = type_id sg; rbody = [ b ] }) + rparams = params; rsig = sg; rsig_id = type_id sg; rbody = [ b ]; + rloc = c.Ast.rloc; + rreport = Option.value c.Ast.rreport ~default:""; + rhidden = hidden }) clauses in let ty = match !ty with Some t -> t | None -> Types.Never in @@ -4558,11 +4562,13 @@ and check_handler_case ctx ?want loc body clauses = rparams = [ { Ast.fname = c.Ast.hname; fty = c.Ast.hty; floc = c.Ast.hloc } ]; - rbody = c.Ast.hbody; rloc = c.Ast.hloc }) + rreport = None; rbody = c.Ast.hbody; rloc = c.Ast.hloc }) clauses rnames in let tbody = check_handler_bind ctx ?want ~what loc handlers [ body ] in - restart_clauses ctx ?want ~what loc tbody landings + (* Hidden: the landing is reached only through the handler above, and a break + loop under this form would otherwise list it as if someone could mean it. *) + restart_clauses ctx ?want ~hidden:true ~what loc tbody landings (* The forms of a [defer], checked in place and hung on the function. What is left where it stands is one store: this defer's number into the counter @@ -6630,7 +6636,8 @@ and alloc_guard ctx loc (attempt : Tast.expr) = an [invoke-restart] cannot tell them apart. *) 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 ] } + rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ]; + rloc = loc; rreport = "Try the allocation again"; rhidden = false } in let body = mk loc Types.Unit (Tast.RestartCase ([ clause ], attempt_then_signal)) @@ -6696,16 +6703,18 @@ and file_guard ctx loc ~path_slot ~op mk_steps = mk loc Types.Bool (Tast.Prim (Tast.Ne, [ attempt; i8 0L ])))); mk loc Types.Unit (Tast.If (notok (), signal (), unit_at loc)) ]) in - let clause name params = + let clause name report params = 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 ] } + rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ]; + rloc = loc; rreport = report; rhidden = false } in let body = mk loc Types.Unit (Tast.RestartCase - ([ clause "retry" []; - clause "use-value" [ (path_slot, Types.String) ] ], + ([ clause "retry" "Try the file operation again" []; + clause "use-value" "Try again with another path" + [ (path_slot, Types.String) ] ], mk loc Types.Unit (Tast.Do (mk_steps try_)))) in mk loc Types.Unit diff --git a/lib/dev.ml b/lib/dev.ml index d83191d7..6eefaeff 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -378,6 +378,15 @@ type restart_flag = let takeable = function Takeable | Boundary -> true | Below -> false +(* One row. After the name, tab-separated, the agent sends what a listing + shows beside it: how many parameters the clause takes, how their types are + spelled, where it is written ([None] for a frame pushed from C) and its + :report sentence, [""] when it wrote none. A row without them — an older + agent — reads as a clause of no parameters with nothing to show. *) +type restart_row = + { ridx : int; rflag : restart_flag; rname : string; rarity : int; + rsig : string; rat : string option; rreport : string } + (* The rows, and whether the break they came from was taken by a trap. *) let restarts t = match ask t "restarts" with @@ -398,17 +407,31 @@ let restarts t = let rest = String.sub line (i + 1) (String.length line - i - 1) in if String.length rest < 2 then None else + let tail = String.sub rest 2 (String.length rest - 2) in + let name, arity, sg, at, report = + match String.split_on_char '\t' tail with + | name :: arity :: sg :: at :: report -> + ( name, + Option.value (int_of_string_opt arity) ~default:0, + sg, + (if at = "-" || at = "" then None else Some at), + String.concat " " report ) + | name :: _ -> (name, 0, "()", None, "") + | [] -> (tail, 0, "()", None, "") + in Some - ( idx, + { ridx = idx; (* An unknown character is read as [Below] rather than as takeable: a flag this end does not recognise is a program newer than the daemon, and refusing a restart that could have been taken is the survivable half of that. *) - (match rest.[0] with - | '+' -> Takeable - | '*' -> Boundary - | _ -> Below), - String.sub rest 2 (String.length rest - 2) )) + rflag = + (match rest.[0] with + | '+' -> Takeable + | '*' -> Boundary + | _ -> Below); + rname = name; rarity = arity; rsig = sg; rat = at; + rreport = report }) in Ok ( List.filter_map parse @@ -1797,11 +1820,26 @@ let break t = rather than filtered, because a client that quietly dropped them would leave someone asking where their restart went. *) ok - ([ ":restarts " ^ Wire.strings (List.map (fun (_, _, n) -> n) rs); + ([ ":restarts " ^ Wire.strings (List.map (fun r -> r.rname) rs); + (* Beside each name and in the same order: its :report sentence, + where the clause is written, and the types it takes. *) + ":details " + ^ Wire.list + (List.map + (fun r -> + Wire.list + [ ":report"; Wire.quote r.rreport; + ":at"; + (match r.rat with + | Some a -> Wire.quote a + | None -> "nil"); + ":arity"; string_of_int r.rarity; + ":params"; Wire.quote r.rsig ]) + rs); ":unreachable " ^ Wire.ints (List.filter_map - (fun (i, f, _) -> if takeable f then None else Some i) + (fun r -> if takeable r.rflag then None else Some r.ridx) rs); (* Which position abandons the evaluation this break is inside, and [nil] when it is not inside one. A position and not the @@ -1811,8 +1849,8 @@ let break t = the name would offer the program's restart as the way out of an evaluation. *) ":abandon " - ^ (match List.find_opt (fun (_, f, _) -> f = Boundary) rs with - | Some (i, _, _) -> string_of_int i + ^ (match List.find_opt (fun r -> r.rflag = Boundary) rs with + | Some r -> string_of_int r.ridx | None -> "nil"); (* Why those positions are refused, which is not the same question as which they are. A break taken by a trap has no diff --git a/lib/emit.ml b/lib/emit.ml index 800e4a71..11267a90 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -163,15 +163,20 @@ module Rt = struct { sname = "handler"; fields = [ "prev", Ptr; "type", I32; "fn", Ptr; "env", Ptr ] } - (* A restart frame. The first four fields are what the runtime's own - [flan_restart] declares and their offsets do not move; the rest are §3's - parameter passing, described where the type is written into the header. *) + (* A restart frame, field for field the runtime's [flan_restart]. The first + four are the lookup; [args] to [siglen] are §3's parameter passing, + described where the type is written into the header; the last five are + for a break loop and nothing reads them on the way to a transfer: where + the clause is written, its [:report] sentence, and [flags], whose bit 0 + says the checker made the clause up (a [handler-case]'s landing). *) let restart = { sname = "restart"; fields = [ "prev", Ptr; "name_id", I32; "name", Ptr; "namelen", I64; "args", Ptr; "arity", I32; "sig_id", I32; "armed", I32; - "sig", Ptr; "siglen", I64 ] } + "sig", Ptr; "siglen", I64; + "loc", Ptr; "loclen", I64; "report", Ptr; "reportlen", I64; + "flags", I32 ] } (* The static description of a function, and the shadow-stack frame that points at one. Dev builds only (runtime/flan_dev.c). *) @@ -2922,6 +2927,14 @@ and emit_restart_case f ty clauses body = let gid, glen = string_bytes f.md c.Tast.rsig in ins f "store ptr %s, ptr %s" gid (restart_field f slot "sig"); ins f "store i64 %d, ptr %s" glen (restart_field f slot "siglen"); + let lid, llen = string_bytes f.md (Loc.to_string c.Tast.rloc) in + ins f "store ptr %s, ptr %s" lid (restart_field f slot "loc"); + ins f "store i64 %d, ptr %s" llen (restart_field f slot "loclen"); + let rid, rlen = string_bytes f.md c.Tast.rreport in + ins f "store ptr %s, ptr %s" rid (restart_field f slot "report"); + 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"); let args = if c.Tast.rparams = [] then None else begin @@ -4298,8 +4311,9 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher ; restart-case, because the invoker's frame is gone by the time a clause runs — ; how many there are, the hash of how they are spelled, whether anything has ; filled the buffer in, and that spelling itself for the message when the two -; ends disagree. The first four fields are what the runtime's own -; [flan_restart] declares and their offsets do not move. +; ends disagree. Then, for a break loop only, where the clause is written, its +; :report sentence, and flags (bit 0: a handler-case's own landing). The C +; [flan_restart] declares every one of these, in this order. |} ^ Rt.ll_type Rt.restart ^ {| ; A shadow-stack frame and the static description of the function that pushed ; it (runtime/flan_dev.c). Dev builds only: [emit_fn] pushes one on entry and diff --git a/lib/parse.ml b/lib/parse.ml index c380830b..51013f02 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -675,11 +675,28 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = in let clause (c : Form.t) = match c.Form.v with + (* [:report "..."] after the parameters is what a break loop shows + beside the name — SBCL's placement, and its string form only. *) + | Form.List + ({ v = Form.Sym n; _ } :: { v = Form.Vec ps; _ } + :: { v = Form.Kw "report"; _ } :: { v = Form.Str r; _ } :: cbody) + when cbody <> [] -> + { Ast.rname = n; rparams = fields c ps; rreport = Some r; + rbody = List.map expr cbody; rloc = c.Form.loc } + | Form.List + ({ v = Form.Sym _; _ } :: { v = Form.Vec _; _ } + :: ({ v = Form.Kw "report"; _ } as k) :: _) -> + fail k + "a restart's :report is a string followed by the clause body, as in \ + (retry [] :report \"Try again\" (do))" | Form.List ({ v = Form.Sym n; _ } :: { v = Form.Vec ps; _ } :: cbody) when cbody <> [] -> - { Ast.rname = n; rparams = fields c ps; + { Ast.rname = n; rparams = fields c ps; rreport = None; rbody = List.map expr cbody; rloc = c.Form.loc } - | _ -> fail c "a restart-case clause is (name [p T] body ...)" + | _ -> + fail c + "a restart-case clause is (name [p T] body ...), or (name [p T] \ + :report \"...\" body ...)" in mk (Ast.RestartCase (expr body, List.map clause clauses)) diff --git a/lib/tast.ml b/lib/tast.ml index 7f1aa9af..576ec30a 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -300,10 +300,16 @@ and hframe = { htype : int; hfn : string; henv : expr option } [rparams] are the slots §3's parameters are bound to, in order, with their types; the invoker stores into a buffer this frame owns and the clause loads them from it. [rsig] is how those types are spelled and [rsig_id] its hash: - what the two ends compare, since neither can see the other. *) + what the two ends compare, since neither can see the other. + + [rloc], [rreport] and [rhidden] are for a break loop and nothing else: where + the clause is written, the sentence it shows beside its name ([""] when it + wrote none), and whether it is one the checker made up — a [handler-case]'s + own landing, which no one at a break loop could mean to take. *) and rclause = { rname_id : int; rname : string; rparams : (int * Types.t) list; - rsig : string; rsig_id : int; rbody : expr list } + rsig : string; rsig_id : int; rbody : expr list; + rloc : Loc.t; rreport : string; rhidden : 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 9d6f15a3..8ceadfbd 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -2118,6 +2118,14 @@ and emit_restart_case f clauses body dst t = str_args f ~preg:rax ~nreg:rcx c.Tast.rsig; store_int f.b ~src:rax ~mm:(Frame (slot + r_sig)) ~size:8; store_int f.b ~src:rcx ~mm:(Frame (slot + r_siglen)) ~size:8; + str_args f ~preg:rax ~nreg:rcx (Loc.to_string c.Tast.rloc); + store_int f.b ~src:rax ~mm:(Frame (slot + r_field "loc")) ~size:8; + store_int f.b ~src:rcx ~mm:(Frame (slot + r_field "loclen")) ~size:8; + str_args f ~preg:rax ~nreg:rcx c.Tast.rreport; + store_int f.b ~src:rax ~mm:(Frame (slot + r_field "report")) ~size:8; + 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; (match args with | None -> () | Some (buf, _) -> diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 51639a60..9f539471 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -87,6 +87,8 @@ void flan_signal(uint32_t type_id, void *condition, void *xfer) { * against every re-entry of the same restart-case. §4's "innermost frame * offering the name" is then just the order of the walk. */ +/* Field for field Emit.Rt.restart, which both backends lay out from one list; + * a field added there is added here, in the same place. */ typedef struct flan_restart { struct flan_restart *prev; uint32_t name_id; @@ -95,8 +97,29 @@ typedef struct flan_restart { * and nothing at run time can turn a hash back into a name. */ const uint8_t *name; int64_t namelen; + /* §3's parameters: the buffer the clause reads them from, how many, the + * hash of their spelling, whether an invoke filled the buffer in, and the + * spelling itself. */ + void *args; + int32_t arity; + uint32_t sig_id; + int32_t armed; + const uint8_t *sig; + int64_t siglen; + /* For a break loop only: where the clause is written, its :report sentence + * (empty when it wrote none), and [flags]. */ + const uint8_t *loc; + int64_t loclen; + const uint8_t *report; + int64_t reportlen; + int32_t flags; } flan_restart; +/* A clause the checker made up rather than one anybody wrote: a + * handler-case's landing, which is reached through its own handler and which + * a break loop does not offer. */ +#define FLAN_RESTART_HIDDEN 1 + static flan_restart *restarts; /* The frames a C caller pushes; see [flan_restart_push_c] below, which is @@ -152,6 +175,35 @@ void *flan_restart_frame(int32_t i) { return NULL; } +/* What a break loop shows about a frame [flan_restart_frame] handed out, read + * off the frame rather than walked for, so a snapshot taking all of them is one + * pass. The strings are the frame's own and live as long as the program. */ +const uint8_t *flan_restart_frame_loc(const void *frame, int64_t *len) { + const flan_restart *r = (const flan_restart *)frame; + *len = r->loclen; + return r->loc; +} + +const uint8_t *flan_restart_frame_report(const void *frame, int64_t *len) { + const flan_restart *r = (const flan_restart *)frame; + *len = r->reportlen; + return r->report; +} + +const uint8_t *flan_restart_frame_sig(const void *frame, int64_t *len) { + const flan_restart *r = (const flan_restart *)frame; + *len = r->siglen; + return r->sig; +} + +int32_t flan_restart_frame_arity(const void *frame) { + return ((const flan_restart *)frame)->arity; +} + +int32_t flan_restart_frame_hidden(const void *frame) { + return (((const flan_restart *)frame)->flags & FLAN_RESTART_HIDDEN) != 0; +} + /* Aim the transfer channel at a frame obtained earlier. The same store an * invoke-restart makes — this only spells it without a lookup, for a caller * that did its looking up when the stack was worth reading. */ @@ -676,12 +728,23 @@ static uint32_t flan_name_id(const uint8_t *s, int64_t n) { * NULL when there is no room, and then the caller simply has no restart to * offer — an evaluation that cannot be abandoned is worse than one that can, * and better than a scribble past the end of this array. */ -void *flan_restart_push_c(const uint8_t *name, int64_t namelen) { +void *flan_restart_push_c(const uint8_t *name, int64_t namelen, + const uint8_t *report, int64_t reportlen) { if (c_restart_depth >= C_RESTARTS) return NULL; flan_restart *r = &c_restarts[c_restart_depth++]; + /* Every field, because the slot is reused: a frame that takes no parameters + * says so with the empty signature a written (name [] ...) has, and one + * pushed from C has no source line. */ + memset(r, 0, sizeof *r); r->name_id = flan_name_id(name, namelen); r->name = name; r->namelen = namelen; + r->sig = (const uint8_t *)"()"; + r->siglen = 2; + r->sig_id = flan_name_id(r->sig, r->siglen); + r->loc = (const uint8_t *)""; + r->report = report; + r->reportlen = reportlen; flan_restart_push(r); return r; } diff --git a/test/agent_hooks.c b/test/agent_hooks.c index e8fb923d..455213e6 100644 --- a/test/agent_hooks.c +++ b/test/agent_hooks.c @@ -31,7 +31,8 @@ void flan_agent_request_free(char *p); extern void (*flan_agent_break_poll_hook)(void); extern void (*flan_break_hook)(const uint8_t *name, int64_t namelen, void *condition, void *xfer); -void *flan_restart_push_c(const uint8_t *name, int64_t namelen); +void *flan_restart_push_c(const uint8_t *name, int64_t namelen, + const uint8_t *report, int64_t reportlen); void flan_restart_pop_c(void *frame); /* The trailing ptr is the transfer channel every Flan signature carries. */ @@ -76,10 +77,14 @@ static void list_and_take(void) { const char *name; int len; if (nl == NULL) break; - /* "I F NAME" */ + /* "I F NAME\tARITY\tSIG\tLOC\tREPORT"; the name ends at the tab. */ name = strchr(p, ' '); name = name ? strchr(name + 1, ' ') : NULL; - len = name ? (int)(nl - name - 1) : -1; + if (name != NULL) { + const char *tab = memchr(name + 1, '\t', (size_t)(nl - name - 1)); + len = (int)((tab != NULL ? tab : nl) - name - 1); + } else + len = -1; if (len > longest) longest = len; if (len < shortest) shortest = len; listed++; @@ -140,7 +145,7 @@ static void stale_hook(void) { if (outer_turns == 1) { void *xin = NULL; printf("outer choice %s", ask("restart-at 1 outer-a")); - inner = flan_restart_push_c((const uint8_t *)"inner", 5); + inner = flan_restart_push_c((const uint8_t *)"inner", 5, NULL, 0); level = 2; flan_break_hook((const uint8_t *)"Inner", 5, NULL, &xin); level = 1; @@ -169,8 +174,8 @@ static void stale_hook(void) { static int stale(void) { void *xout = NULL; - outer_a = flan_restart_push_c((const uint8_t *)"outer-a", 7); - outer_b = flan_restart_push_c((const uint8_t *)"outer-b", 7); + outer_a = flan_restart_push_c((const uint8_t *)"outer-a", 7, NULL, 0); + outer_b = flan_restart_push_c((const uint8_t *)"outer-b", 7, NULL, 0); level = 1; flan_agent_break_poll_hook = stale_hook; flan_break_hook((const uint8_t *)"Outer", 5, NULL, &xout); diff --git a/test/programs/break.flan b/test/programs/break.flan index fe37c9bb..3399fcbe 100644 --- a/test/programs/break.flan +++ b/test/programs/break.flan @@ -11,7 +11,7 @@ (defn fetch [n i32] i32 (restart-case (do (error (Missing {.id n})) 0) - (use-placeholder [] -1) + (use-placeholder [] :report "Answer -1 for the missing value" -1) (retry [] 7))) ;;; Two frames offering the same name, which §4 says resolves to the inner one @@ -26,9 +26,21 @@ 100) (retry [] 900))) +(defstruct Other []) + +;;; A handler-case establishes a restart of its own, under a name nobody wrote, +;;; and a break loop inside it must not offer that one: it is reached through +;;; the form's handler, which carries the condition in. Only [keep] is listed. +(defn caught [n i32] i32 + (restart-case + (handler-case (do (error (Missing {.id n})) 0) + [(Other [_o] 5)]) + (keep [] :report "Answer 42" 42))) + (defn main [] i32 (agent/start "/tmp/flan-break.sock") (print (fetch 1)) (println "") (print (fetch 2)) (println "") (print (shadowed 3)) (println "") + (print (caught 4)) (println "") 0) diff --git a/test/programs/dev-break.flan b/test/programs/dev-break.flan index 24a353c9..706b5452 100644 --- a/test/programs/dev-break.flan +++ b/test/programs/dev-break.flan @@ -15,7 +15,7 @@ (defn fetch [n i32] i32 (restart-case (do (error (Missing {.id n})) 0) - (use-placeholder [] -1) + (use-placeholder [] :report "Answer -1" -1) (retry [] 7))) (defonce ticks i64) diff --git a/test/test_agent.ml b/test/test_agent.ml index 91a2489f..def7521c 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -32,6 +32,17 @@ let fail fmt = Test_support.fail fmt let tmp name = Test_support.tmp "flan-agent-" name let await ?(ms = 3000) f = Test_support.await ~ms f +(* A [restarts] reply with each row cut at its first tab: the index, the flag + and the name, which is what most checks below are about. *) +let names_only reply = + String.concat "\n" + (List.map + (fun l -> + match String.index_opt l '\t' with + | Some i -> String.sub l 0 i + | None -> l) + (String.split_on_char '\n' reply)) + let send path line = let s = Test_support.connect ~ms:2000 path in let msg = line ^ "\n" in @@ -421,9 +432,17 @@ let () = then fail "the program never reached the break loop: %S" !listed else begin (* Innermost first, and both on offer. *) - if !listed <> "0 + retry\n1 + use-placeholder\n.\n" then + (* After each name, tab-separated: the parameter count, their + spelling, where the clause is written, and its :report sentence — + empty for [retry], which wrote none. *) + let want = + "0 + retry\t0\t()\tprograms/break.flan:15:5\t\n\ + 1 + use-placeholder\t0\t()\tprograms/break.flan:14:5\t\ + Answer -1 for the missing value\n.\n" + in + if !listed <> want then fail "restarts on offer\n got: %S\n wanted: %S" !listed - "0 + retry\n1 + use-placeholder\n.\n"; + want; (* A name nothing offers is refused *here*, before the reply. Answering ok and discovering it on the game thread would report success for something that cannot happen. *) @@ -443,7 +462,7 @@ let () = in if not (await printed) then fail "the first restart never produced its value" - else if not (await (fun () -> send bsock "restarts" + else if not (await (fun () -> names_only (send bsock "restarts") = "0 + retry\n1 + use-placeholder\n.\n")) then fail "the program never stopped a second time" else begin @@ -462,7 +481,7 @@ let () = in if not (await printed2) then fail "the second restart never produced its value" - else if not (await (fun () -> send bsock "restarts" + else if not (await (fun () -> names_only (send bsock "restarts") = "0 + retry\n1 + retry\n.\n")) then fail "the program never stopped on the shadowed pair" else begin @@ -476,7 +495,13 @@ let () = let drift = send bsock "restart-at 1 use-placeholder" in if not (String.length drift >= 3 && String.sub drift 0 3 = "err") then fail "an index whose name had drifted was accepted: %S" drift; - ignore (send bsock "restart-at 1 retry") + ignore (send bsock "restart-at 1 retry"); + if not (await (fun () -> + names_only (send bsock "restarts") = "0 + keep\n.\n")) + then + fail "a handler-case's own restart was listed: %S" + (send bsock "restarts") + else ignore (send bsock "restart-at 0 keep") end end end @@ -494,7 +519,7 @@ let () = end else begin let text = In_channel.with_open_bin bout In_channel.input_all in - let want = "7\n-1\n900\n" in + let want = "7\n-1\n900\n42\n" in let got = String.concat "\n" (List.filter diff --git a/test/test_dev.ml b/test/test_dev.ml index 169a2eee..e3905ac5 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -925,6 +925,19 @@ let () = if names <> [ "retry"; "use-placeholder" ] then fail "restarts on offer: %s" (String.concat ", " names) | _ -> fail "break did not list the restarts"); + (* Beside each name, in the same order: its :report sentence and + where its clause is written. [retry] wrote no report. *) + (match Wire.field r "details" with + | Some { Form.v = Form.List [ d0; d1 ]; _ } -> + let str = Wire.string_field in + if str d0 "report" <> Some "" || str d1 "report" <> Some "Answer -1" + then fail "the restarts' reports did not arrive"; + (match str d1 "at" with + | Some at when contains_sub at "dev-break.flan:18:" -> () + | at -> + fail "use-placeholder's clause is at %s" + (Option.value at ~default:"nowhere")) + | _ -> fail "break did not carry a detail per restart"); (* Where it is, which is the other half of what a stopped program can be asked. The shadow stack is dev-only and the daemon owns the diff --git a/test/test_flan.ml b/test/test_flan.ml index d7857883..5faba7f1 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3307,6 +3307,14 @@ let () = (* The rule the blanket one could not express, both ways round. A loop wholly inside a restart-case body keeps its local break; a break that would *leave* the restart-case is refused, and says so. *) + (* SBCL's placement for a clause's report: after the parameters. *) + accepts "a restart clause may carry a :report sentence" + "(defn f [] i64 (restart-case 1 (retry [] :report \"Try again\" (do) 2)))"; + accepts "the suggested :report spelling compiles" + "(defn f [] () (restart-case (do) (retry [] :report \"Try again\" (do))))"; + parse_rejects "a :report that is not a string is refused" + "(defn f [] i64 (restart-case 1 (retry [] :report 5 2)))" + ~needle:"a restart's :report is a string"; accepts "a loop inside a restart-case may break out of itself" "(defn f [] () (restart-case (while true (break)) (go [] (println \"\"))))"; rejects_check "break may not leave a restart-case" diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 2ca2aadb..1d68edf6 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -334,7 +334,15 @@ extern int64_t flan_break_site_len; /* A restart frame with no Flan function under it, which is what the boundary * below is made of. The storage belongs to flan_rt.c for the reason the * shadow-stack frame's shape does: the struct is declared in one file. */ -extern void *flan_restart_push_c(const uint8_t *name, int64_t namelen); +extern void *flan_restart_push_c(const uint8_t *name, int64_t namelen, + const uint8_t *report, int64_t reportlen); +/* What a break loop shows about a restart beyond its name, read off a frame + * [flan_restart_frame] handed out. */ +extern const uint8_t *flan_restart_frame_loc(const void *frame, int64_t *len); +extern const uint8_t *flan_restart_frame_report(const void *frame, int64_t *len); +extern const uint8_t *flan_restart_frame_sig(const void *frame, int64_t *len); +extern int32_t flan_restart_frame_arity(const void *frame); +extern int32_t flan_restart_frame_hidden(const void *frame); extern void flan_restart_pop_c(void *frame); /* -- How far down a transfer can actually land ----------------------- */ @@ -401,6 +409,8 @@ static int32_t frame_floor = -1; * around the call like the floors, so nesting names the innermost. */ static void *eval_boundary; static const uint8_t abandon_name[] = "abandon-evaluation"; +static const uint8_t abandon_report[] = + "Stop running the expression; the program carries on"; /* The three of them, dropped between two runs of [main]. The counterpart of * flan_rt.c's [flan_condition_stacks_reset] and flan_dev.c's @@ -472,6 +482,8 @@ static _Atomic int aborting; * comes from here and nothing re-reads the live stack. */ #define SNAP_MAX 64 /* restarts offered at one break */ #define SNAP_NAMES 4096 /* bytes of names behind them */ +#define SNAP_TEXT 16384 /* and of what a listing shows + * beside each name */ #define FRAME_MAX 64 /* frames listed in a backtrace */ #define FRAME_TEXT 8192 /* bytes of names and locations */ @@ -505,6 +517,17 @@ typedef struct { int32_t boundary; int32_t used; char names[SNAP_NAMES]; + /* Beside each name: how many parameters the clause takes, how their types + * are spelled, where the clause is written and its :report sentence. Copied + * for the reason the names are — the frame they are read from can be popped + * while this break is still being asked about. Tabs and newlines in them are + * spaces here, because a tab is what separates them on the wire. */ + int32_t arity[SNAP_MAX]; + int32_t sigoff[SNAP_MAX], siglen[SNAP_MAX]; + int32_t locoff[SNAP_MAX], loclen[SNAP_MAX]; + int32_t repoff[SNAP_MAX], replen[SNAP_MAX]; + int32_t tused; + char text[SNAP_TEXT]; /* Where the stopped thread is, taken at the same moment and for the same * reason: the chain is the game thread's, and it is holding still only * because it is parked in this loop. [fframe] is kept as well as the text, @@ -588,6 +611,36 @@ static snapshot *snap_top(void) { return d <= 0 ? NULL : &snaps[d - 1]; } +/* One string into the snapshot's text pool, with its offset and length. A + * string that does not fit is recorded as empty rather than cut: an empty + * report or location is a state the reader handles, and half of one is not. */ +static void snap_text(snapshot *s, const uint8_t *p, int64_t n, int32_t *off, + int32_t *len) { + *off = s->tused; + *len = 0; + if (p == NULL || n <= 0 || (int64_t)s->tused + n + 1 > SNAP_TEXT) return; + for (int64_t i = 0; i < n; i++) { + char c = (char)p[i]; + s->text[s->tused + i] = (c == '\t' || c == '\n' || c == '\r') ? ' ' : c; + } + s->tused += (int32_t)n; + s->text[s->tused++] = 0; + *len = (int32_t)n; +} + +/* The four facts about entry [k] beside its name, off its frame. */ +static void snap_detail(snapshot *s, int32_t k, const void *fr) { + int64_t n; + const uint8_t *p; + s->arity[k] = flan_restart_frame_arity(fr); + p = flan_restart_frame_sig(fr, &n); + snap_text(s, p, n, &s->sigoff[k], &s->siglen[k]); + p = flan_restart_frame_loc(fr, &n); + snap_text(s, p, n, &s->locoff[k], &s->loclen[k]); + p = flan_restart_frame_report(fr, &n); + snap_text(s, p, n, &s->repoff[k], &s->replen[k]); +} + /* Called on the game thread with the stack held still. 0 if there is no room * to nest, which the caller reports rather than serving a stale one. */ static int32_t snap_gen; /* monotone; 0 is "no snapshot" */ @@ -621,6 +674,7 @@ static int snap_push(int resumable, void *cond) { } s->total = n; s->used = 0; + s->tused = 0; s->n = 0; s->boundary = -1; /* One slot and one name's worth of bytes kept back for the boundary, and the @@ -643,6 +697,12 @@ static int snap_push(int resumable, void *cond) { const uint8_t *nm = flan_restart_name(i, &len); void *fr = flan_restart_frame(i); if (nm == NULL || fr == NULL) continue; + /* A handler-case's own landing is left off. It is reached through the + * handler the form installed, carries the condition that handler copies + * in, and has nothing to offer a person at a break loop — taking it by + * hand is refused at the clause for want of that condition. Dropped from + * the count as well, so "and N more" counts only what could be listed. */ + if (flan_restart_frame_hidden(fr)) { s->total--; continue; } if (len < 0) len = 0; if ((int64_t)s->used + len + 1 > SNAP_NAMES - held_bytes) break; s->frame[s->n] = fr; @@ -651,6 +711,7 @@ static int snap_push(int resumable, void *cond) { /* The outermost [restart_floor] frames are below the thunk boundary. */ s->reachable[s->n] = (i < n - restart_floor); if (fr == eval_boundary && eval_boundary != NULL) s->boundary = s->n; + snap_detail(s, s->n, fr); memcpy(s->names + s->used, nm, (size_t)len); s->used += (int32_t)len; s->names[s->used++] = 0; @@ -672,6 +733,7 @@ static int snap_push(int resumable, void *cond) { * is what [reachable] is measured against. */ s->reachable[s->n] = 1; s->boundary = s->n; + snap_detail(s, s->n, eval_boundary); memcpy(s->names + s->used, abandon_name, (size_t)len); s->used += len; s->names[s->used++] = 0; @@ -860,7 +922,11 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition, * not takeable - a restart below the thunk boundary is shown rather * than hidden, since "why can I not have that one" is a fair question * and silence is how this went wrong the first time. */ - fprintf(stderr, " %2d. restart: %s%s\n", i, s->names + s->off[i], + fprintf(stderr, " %2d. restart: %s%s%s%s\n", i, s->names + s->off[i], + /* Not for the boundary, whose own words follow. */ + s->replen[i] > 0 && i != s->boundary ? " — " : "", + s->replen[i] > 0 && i != s->boundary ? s->text + s->repoff[i] + : "", !s->resumable ? " (cannot be taken from this trap)" : i == s->boundary ? " (stop running the expression; the program carries on)" @@ -1041,7 +1107,9 @@ int32_t flan_agent_poll(void) { /* After the floor is read and not before: the floor counts the frames * that were there when the thunk started, and this one is the thunk's. * Pushed first it would be below its own boundary and refused. */ - eval_boundary = flan_restart_push_c(abandon_name, sizeof abandon_name - 1); + eval_boundary = flan_restart_push_c(abandon_name, sizeof abandon_name - 1, + abandon_report, + sizeof abandon_report - 1); j.call(); /* Popped whichever way the thunk left — returning with a value, or * unwinding past this frame because someone abandoned it. */ @@ -1234,7 +1302,14 @@ static void handle_line(char *line, sink *o) { * for whether it can be taken at all, and the name. The index leads * because it is the identity - two frames can offer [retry] and only one * of them is the one meant, which is the whole reason this is not a list - * of names any more. Read from the snapshot, never from the live stack. */ + * of names any more. Read from the snapshot, never from the live stack. + * + * After the name, each behind a tab: how many parameters the clause takes, + * how their types are spelled, where it is written ([-] for a frame pushed + * from C) and its :report sentence, which may be empty and may contain + * spaces, so it is last. A tab because a name has no space in it and a + * report does; the snapshot has already turned any tab in them to a + * space. */ if (strcmp(line, "restarts") == 0) { if (!(atomic_load(&depth) > 0)) { reply(o, "err not stopped\n"); return; } snapshot *s = snap_top(); @@ -1273,6 +1348,14 @@ static void handle_line(char *line, sink *o) { : '+'); if (k > 0) emit(o, hdr, (size_t)k); emit(o, s->names + s->off[i], (size_t)s->len[i]); + k = snprintf(hdr, sizeof hdr, "\t%d\t", s->arity[i]); + if (k > 0) emit(o, hdr, (size_t)k); + emit(o, s->text + s->sigoff[i], (size_t)s->siglen[i]); + reply(o, "\t"); + if (s->loclen[i] > 0) emit(o, s->text + s->locoff[i], (size_t)s->loclen[i]); + else reply(o, "-"); + reply(o, "\t"); + emit(o, s->text + s->repoff[i], (size_t)s->replen[i]); reply(o, "\n"); } reply(o, ".\n");